perm filename GEO[AM,DBL]1 blob
sn#207261 filedate 1976-03-25 generic text, type T, neo UTF8
(FILECREATED "25-MAR-76 02:05:14" <LENAT>GEO.;1 17036
changes to: ALWAYS-DEFINED ALWAYS-UNIQUE ANG ANG-EQ INTERCEPT LIN MEAS NUM-BETWEEN POINTP PT RDIST SLOPE SQ TRI
GEOCOMS GEOFNS GEOCONS)
(LISPXPRINT (QUOTE GEOCOMS)
T T)
[RPAQQ GEOCOMS ((FNS * GEOFNS)
GEOFNS GEOCONS [COMS * (LIST (CONS (QUOTE IFPROP)
(CONS (QUOTE ALL)
GEOCONS]
(P (MAPC GEOCONS (QUOTE NEW-CON]
(DEFINEQ
(ALWAYS-DEFINED
[LAMBDA NIL])
(ALWAYS-UNIQUE
[LAMBDA NIL])
(ANG
[NLAMBDA X
(CONS (QUOTE ANG)
X])
(ANG-EQ
[LAMBDA (A1 A2)
(AND (APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
A1)
(APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
A2])
(INTERCEPT
[LAMBDA (L X1 X2 Y1 Y2 P1 P2)
(SETQ P1 (CADR L))
(SETQ P2 (CADDR L))
(SETQ X1 (CADR P1))
(SETQ Y1 (CADDR P1))
(SETQ X2 (CADR P2))
(SETQ Y2 (CADDR P2))
(COND
((EQUAL X1 X2)
1000)
(T (QUOTIENT (DIFFERENCE (TIMES X1 Y2)
(TIMES X2 Y1))
(DIFFERENCE X1 X2])
(LIN
[NLAMBDA X
(CONS (QUOTE LIN)
X])
(MEAS
[LAMBDA (P1 P2 P3 A B C Z)
(SETQ A (RDIST P1 P3))
(SETQ B (RDIST P1 P2))
(SETQ C (RDIST P2 P3))
(SETQ Z (QUOTIENT (DIFFERENCE (PLUS (SQ B)
(SQ C))
(SQ A))
(TIMES 2 B C)))
(ARCCOS Z])
(NUM-BETWEEN
[LAMBDA (A B C)
(COND
((LESSP A B)
(NOT (LESSP C B)))
((NOT (LESSP B C])
(POINTP
[LAMBDA (BA1)
(MATCH BA1 WITH ('PT &@NUMBERP &@NUMBERP])
(PT
[NLAMBDA X
(CONS (QUOTE PT)
X])
(RDIST
[LAMBDA (P1 P2)
(COND
[(AND (POINTP P1)
(POINTP P2))
(SQRT (PLUS (SQ (DIFFERENCE (CADR P1)
(CADR P2)))
(SQ (DIFFERENCE (CADDR P1)
(CADDR P2]
(0])
(SLOPE
[LAMBDA (L X1 X2 Y1 Y2 P1 P2)
(SETQ P1 (CADR L))
(SETQ P2 (CADDR L))
(SETQ X1 (CADR P1))
(SETQ Y1 (CADDR P1))
(SETQ X2 (CADR P2))
(SETQ Y2 (CADDR P2))
(COND
((EQUAL X1 X2)
1000)
(T (QUOTIENT (DIFFERENCE Y1 Y2)
(DIFFERENCE X1 X2])
(SQ
[LAMBDA (X)
(COND
((NUMBERP X)
(TIMES X X))
(0])
(TRI
[NLAMBDA X
(CONS (QUOTE TRI)
X])
)
(RPAQQ GEOFNS (ALWAYS-DEFINED ALWAYS-UNIQUE ANG ANG-EQ INTERCEPT LIN MEAS NUM-BETWEEN POINTP PT RDIST SLOPE SQ TRI))
(RPAQQ GEOCONS (ANGLE ANGLE-EQUAL BETWEEN COLLINEAR DISTANCE DRAW-ANGLE DRAW-LINE DRAW-TRIANGLE FUNC LINE LINE-EQUAL
MEASURE-ANGLE MEASURE-TRIANGLE POINT RIGHT-ANGLE STRAIGHT-ANGLE TRIANGLE TRIANGLE-EQUAL))
(PUTPROPS ANGLE GENL (OBJECT ORD-OBJ)
WORTH (700 500 0 300)
DEFN [(TYPE NONRECURSIVE OPAQUE (MATCH BA1 WITH ((QUOTE ANG)
&@POINTP &@POINTP &@POINTP]
IN-RAN-OF (DRAW-ANGLE)
UP (ANY-STRUC)
EXS ((ANG (PT 0 0)
(PT 10 10)
(PT 10 0))
(ANG (PT 20 0)
(PT 3 3)
(PT 3 20)))
EXS-BDY ((ANG (PT 0 0)
(PT 1 1)
(PT 10 10))
(ANG (PT 1 0)
(PT 0 0)
(PT 0 5)))
EXS-NOT-BDY ((VECTOR (PT 1 3)
(PT 2 5)
(PT 33 0)))
EXS-NOT (T NIL (ANG)
(BAG))
IN-DOM-OF (ANGLE-EQUAL)
SPEC (RIGHT-ANGLE STRAIGHT-ANGLE))
(PUTPROPS ANGLE-EQUAL WORTH (400 200 100 60)
ALGS [(TYPE QUASIRECURSIVE REDUCING-TO MEASURE-ANGLE (AND (APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
BA2)
(EQUAL (APPLYB (QUOTE MEASURE-ANGLE)
(QUOTE ALGS)
BA1)
(APPLYB (QUOTE MEASURE-ANGLE)
(QUOTE ALGS)
BA2]
D-R ((ANGLE ANGLE TRUTH-VAL))
GUP (PREDICATE)
DEFN [(TYPE QUASIRECURSIVE REDUCING-TO MEASURE-ANGLE (AND (APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
BA2)
(EQUAL (APPLYB (QUOTE MEASURE-ANGLE)
(QUOTE ALGS)
BA1)
(APPLYB (QUOTE MEASURE-ANGLE)
(QUOTE ALGS)
BA2]
UP (PREDICATE ACTIVE))
(PUTPROPS BETWEEN WORTH (300 200 400 60)
ALGS ((TYPE NONRECURSIVE OPAQUE (AND (APPLYB (QUOTE COLLINEAR)
(QUOTE DEFN)
BA1 BA2 BA3)
(NUM-BETWEEN (CADDR BA2)
(CADDR BA1)
(CADDR BA3))
(NUM-BETWEEN (CADR BA2)
(CADR BA1)
(CADR BA3))
T)))
D-R ((POINT POINT POINT TRUTH-VAL))
DEFN ((TYPE NONRECURSIVE OPAQUE (AND (APPLYB (QUOTE COLLINEAR)
(QUOTE DEFN)
BA1 BA2 BA3)
(NUM-BETWEEN (CADDR BA2)
(CADDR BA1)
(CADDR BA3))
(NUM-BETWEEN (CADR BA2)
(CADR BA1)
(CADR BA3))
T)))
GENL (COLLINEAR))
(PUTPROPS COLLINEAR WORTH (300 200 400 60)
ALGS [(TYPE QUASIRECURSIVE REDUCING-TO LINE-EQUAL (AND (POINTP BA1)
(POINTP BA2)
(POINTP BA3)
(APPLYB (QUOTE LINE-EQUAL)
(QUOTE ALGS)
(APPLYB (QUOTE DRAW-LINE)
(QUOTE ALGS)
BA1 BA2)
(APPLYB (QUOTE DRAW-LINE)
(QUOTE ALGS)
BA1 BA3]
SPEC (BETWEEN)
D-R ((POINT POINT POINT TRUTH-VAL))
GUP (PREDICATE)
DEFN [(TYPE QUASIRECURSIVE REDUCING-TO LINE-EQUAL (AND (POINTP BA1)
(POINTP BA2)
(POINTP BA3)
(APPLYB (QUOTE LINE-EQUAL)
(QUOTE DEFN)
(APPLYB (QUOTE DRAW-LINE)
(QUOTE ALGS)
BA1 BA2)
(APPLYB (QUOTE DRAW-LINE)
(QUOTE ALGS)
BA1 BA3]
UP (PREDICATE ACTIVE))
(PUTPROPS DISTANCE WORTH (500 100 0 500)
ALGS [(TYPE NONRECURSIVE OPAQUE QUICK
(AND (POINTP BA1)
(POINTP BA2)
(FIX (PLUS .5 (SQRT (PLUS (SQ (DIFFERENCE (CADR BA1)
(CADR BA2)))
(SQ (DIFFERENCE (CADDR BA1)
(CADDR BA2]
D-R ((POINT POINT NUMBER))
GUP (FUNC)
UP (FUNC OPERATION ACTIVE)
DEFN [(TYPE NONRECURSIVE OPAQUE QUICK
(AND (POINTP BA1)
(POINTP BA2)
(EQUAL BA3 (FIX (PLUS .5 (SQRT (PLUS (SQ (DIFFERENCE (CADR BA1)
(CADR BA2)))
(SQ (DIFFERENCE (CADDR BA1)
(CADDR BA2])
(PUTPROPS DRAW-ANGLE WORTH (300 100 0 50)
ALGS [(TYPE NONRECURSIVE OPAQUE QUICK (AND (POINTP BA1)
(POINTP BA2)
(POINTP BA3)
(NOT (EQUAL BA3 BA2))
(NOT (EQUAL BA1 BA2))
(CONS (QUOTE ANG)
(SORT (LIST BA1 BA2 BA3)
(QUOTE SORD]
D-R ((POINT POINT POINT ANGLE))
GUP (FUNC)
UP (FUNC OPERATION ACTIVE)
DEFN [(TYPE NONRECURSIVE OPAQUE QUICK (AND BA1 BA2 BA3 BA4 (EQUAL BA4 (APPLYB (QUOTE DRAW-ANGLE)
(QUOTE ALGS)
BA1 BA2 BA3])
(PUTPROPS DRAW-LINE WORTH (300 100 0 50)
ALGS [(TYPE NONRECURSIVE OPAQUE QUICK (AND (POINTP BA1)
(POINTP BA2)
(NOT (EQUAL BA1 BA2))
(CONS (QUOTE LIN)
(SORT (LIST BA1 BA2)
(QUOTE SORD]
D-R ((POINT POINT LINE))
GUP (FUNC)
UP (FUNC OPERATION ACTIVE)
DEFN [(TYPE NONRECURSIVE OPAQUE QUICK (AND BA1 BA2 BA3 (EQUAL BA3 (APPLYB (QUOTE DRAW-LINE)
(QUOTE ALGS)
BA1 BA2])
(PUTPROPS DRAW-TRIANGLE WORTH (300 100 0 50)
ALGS [(TYPE NONRECURSIVE OPAQUE QUICK (AND (POINTP BA1)
(POINTP BA2)
(POINTP BA3)
(NOT (EQUAL BA3 BA2))
(NOT (EQUAL BA1 BA3))
(NOT (EQUAL BA1 BA2))
(CONS (QUOTE TRI)
(SORT (LIST BA1 BA2 BA3)
(QUOTE SORD]
D-R ((POINT POINT POINT TRIANGLE))
GUP (FUNC)
UP (FUNC OPERATION ACTIVE)
DEFN [(TYPE NONRECURSIVE OPAQUE QUICK (AND BA1 BA2 BA3 BA4 (EQUAL BA4 (APPLYB (QUOTE
DRAW-TRIANGLE)
(QUOTE ALGS)
BA1 BA2 BA3])
(PUTPROPS FUNC GENL (OPERATION)
WORTH (800 900 200 0)
EXS (PROJ1 PROJ2 REAR REV-ORD-PAIR STRUCTURE-DELETE STRUCTURE-DIFF STRUCTURE-INSERT
STRUCTURE-INTERSECT BAG-STRUC-DIFF BAG-STRUC-JOIN FINAL FIRST MAP-JOIN MAP-REPLACE
MAP-REPLACE2 SET-STRUC-INTERSECT ADD CROSS-PRODUCT DIVIDE INV-SQUARE MAXI MINI MULTIPLY
SUBTRACT DISTANCE DRAW-LINE MEASURE-ANGLE)
DEFN [(TYPE NONRECURSIVE OPAQUE (OR (FMEMB BA1 (ACEX FUNC))
(AND (ALWAYS-DEFINED BA1)
(ALWAYS-UNIQUE BA1])
(PUTPROPS LINE GENL (OBJECT)
WORTH (700 500 0 300)
DEFN [(TYPE NONRECURSIVE OPAQUE (MATCH BA1 WITH ('PT &@POINTP &@POINTP]
IN-RAN-OF (DRAW-LINE)
UP (ANY-STRUC)
EXS ((LIN (PT 0 0)
(PT 10 10))
(LIN (PT 10 0)
(PT 10 0)))
EXS-BDY ((LIN (PT 0 0)
(PT 0 0)))
EXS-NOT-BDY ((PAIR (PT 10 10)
(PT 10 10))
(LIN (PT 10 10)))
EXS-NOT (T NIL (LIN)
(BAG))
IN-DOM-OF (LINE-EQUAL))
(PUTPROPS LINE-EQUAL WORTH (600 200 100 60)
ALGS ((TYPE NONRECURSIVE OPAQUE (AND (APPLYB (QUOTE LINE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE LINE)
(QUOTE DEFN)
BA2)
(EQUAL (SLOPE BA1)
(SLOPE BA2))
(EQUAL (INTERCEPT BA1)
(INTERCEPT BA2))
T)))
D-R ((LINE LINE TRUTH-VAL))
GUP (PREDICATE)
DEFN ((TYPE NONRECURSIVE OPAQUE (AND (APPLYB (QUOTE LINE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE LINE)
(QUOTE DEFN)
BA2)
(EQUAL (SLOPE BA1)
(SLOPE BA2))
(EQUAL (INTERCEPT BA1)
(INTERCEPT BA2))
T)))
UP (PREDICATE ACTIVE))
(PUTPROPS MEASURE-ANGLE WORTH (600 100 0 600)
ALGS [(TYPE NONRECURSIVE OPAQUE QUICK (AND (APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
BA1)
(NUMBERP BA2)
(NOT (EQUAL (CADR BA1)
(CADDR BA1)))
(NOT (EQUAL (CADDR BA1)
(CADDDR BA1)))
(EQUAL BA2 (FIX (PLUS .5 (MEAS (CADR BA1)
(CADDR BA1)
(CADDDR BA1]
D-R ((ANGLE NUMBER))
GUP (FUNC)
UP (FUNC OPERATION ACTIVE)
DEFN [(TYPE NONRECURSIVE OPAQUE QUICK (AND (APPLYB (QUOTE ANGLE)
(QUOTE DEFN)
BA1)
(NUMBERP BA2)
(NOT (EQUAL (CADR BA1)
(CADDR BA1)))
(NOT (EQUAL (CADDR BA1)
(CADDDR BA1)))
(EQUAL BA2 (FIX (PLUS .5 (MEAS (CADR BA1)
(CADDR BA1)
(CADDDR BA1])
(PUTPROPS MEASURE-TRIANGLE WORTH (600 100 0 600)
DEFN [(TYPE NONRECURSIVE OPAQUE QUICK
(AND (APPLYB (QUOTE TRIANGLE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE BAG-OF-NUMBERS)
(QUOTE DEFN)
BA2)
(EQUAL BA2 (CONS (QUOTE BAG)
(SORT (LIST (APPLYB (QUOTE DISTANCE)
(QUOTE ALGS)
(CADR BA1)
(CADDR BA1))
(APPLYB (QUOTE DISTANCE)
(QUOTE ALGS)
(CADR BA1)
(CADDDR BA1))
(APPLYB (QUOTE DISTANCE)
(QUOTE ALGS)
(CADDDR BA1)
(CADDR BA1]
D-R ((TRIANGLE BAG-OF-NUMBERS))
GUP (FUNC)
UP (FUNC OPERATION ACTIVE)
ALGS [(TYPE NONRECURSIVE OPAQUE QUICK (AND (APPLYB (QUOTE TRIANGLE)
(QUOTE DEFN)
BA1)
(CONS (QUOTE BAG)
(SORT (LIST (APPLYB (QUOTE DISTANCE)
(QUOTE ALGS)
(CADR BA1)
(CADDR BA1))
(APPLYB (QUOTE DISTANCE)
(QUOTE ALGS)
(CADR BA1)
(CADDDR BA1))
(APPLYB (QUOTE DISTANCE)
(QUOTE ALGS)
(CADDDR BA1)
(CADDR BA1])
(PUTPROPS POINT GENL (OBJECT)
IN-DOM-OF (DISTANCE DRAW-LINE COLLINEAR BETWEEN MIDPOINT MEASURE-ANGLE)
WORTH (700 500 0 300)
DEFN ((TYPE NONRECURSIVE OPAQUE (POINTP BA1)))
IN-RAN-OF (MIDPOINT VERTEX)
UP (ANY-STRUC)
EXS ((PT 0 0)
(PT 10 10)
(PT 0 10)
(PT 10 0)
(PT 0 20)
(PT 30 30))
EXS-BDY ((PT 0 0))
EXS-NOT-BDY ((PAIR 10 10)
(PT 10))
EXS-NOT (T NIL (PT)
(BAG)))
(PUTPROPS RIGHT-ANGLE GENL (ANGLE)
WORTH (700 500 0 350)
DEFN ((TYPE QUASIRECURSIVE REDUCING-TO MEASURE-ANGLE (APPLYB (QUOTE MEASURE-ANGLE)
(QUOTE DEFN)
BA1 90))))
(PUTPROPS STRAIGHT-ANGLE GENL (ANGLE)
WORTH (700 500 0 350)
DEFN ((TYPE QUASIRECURSIVE REDUCING-TO MEASURE-ANGLE (APPLYB (QUOTE MEASURE-ANGLE)
(QUOTE DEFN)
BA1 180))))
(PUTPROPS TRIANGLE GENL (OBJECT UNORD-OBJ)
WORTH (700 500 0 300)
DEFN [(TYPE NONRECURSIVE OPAQUE (MATCH BA1 WITH ('TRI &@POINTP &@POINTP &@POINTP]
IN-RAN-OF (DRAW-TRIANGLE)
UP (ANY-STRUC)
EXS ((TRI (PT 0 0)
(PT 10 10)
(PT 10 0))
(TRI (PT 20 0)
(PT 3 3)
(PT 3 20)))
EXS-BDY ((TRI (PT 0 0)
(PT 1 1)
(PT 10 10))
(TRI (PT 1 0)
(PT 0 0)
(PT 0 5)))
EXS-NOT-BDY ((VECTOR (PT 1 3)
(PT 2 5)
(PT 33 0)))
EXS-NOT (T NIL (TRI)
(BAG))
IN-DOM-OF (TRIANGLE-EQUAL))
(PUTPROPS TRIANGLE-EQUAL WORTH (400 200 100 60)
ALGS [(TYPE QUASIRECURSIVE REDUCING-TO MEASURE-TRIANGLE (AND (APPLYB (QUOTE TRIANGLE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE TRIANGLE)
(QUOTE DEFN)
BA2)
(EQUAL (APPLYB (QUOTE
MEASURE-TRIANGLE)
(QUOTE ALGS)
BA1)
(APPLYB (QUOTE
MEASURE-TRIANGLE)
(QUOTE ALGS)
BA2]
D-R ((TRIANGLE TRIANGLE TRUTH-VAL))
GUP (PREDICATE)
DEFN [(TYPE QUASIRECURSIVE REDUCING-TO MEASURE-TRIANGLE (AND (APPLYB (QUOTE TRIANGLE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE TRIANGLE)
(QUOTE DEFN)
BA2)
(EQUAL (APPLYB (QUOTE
MEASURE-TRIANGLE)
(QUOTE ALGS)
BA1)
(APPLYB (QUOTE
MEASURE-TRIANGLE)
(QUOTE ALGS)
BA2]
UP (PREDICATE ACTIVE)
IDEN "Congruence")
(MAPC GEOCONS (QUOTE NEW-CON))
(LISPXPRINT (QUOTE GEOCOMS)
T T)
[RPAQQ GEOCOMS ((FNS * GEOFNS)
GEOFNS GEOCONS [COMS * (LIST (CONS (QUOTE IFPROP)
(CONS (QUOTE ALL)
GEOCONS]
(P (MAPC GEOCONS (QUOTE NEW-CON)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA TRI PT LIN ANG)
(NLAML]
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TRI PT LIN ANG)
(ADDTOVAR NLAML)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (425 2214 (ALWAYS-DEFINED 437 . 469) (ALWAYS-UNIQUE 473 . 504) (ANG 508 . 557) (ANG-EQ 561 . 695) (
INTERCEPT 699 . 1032) (LIN 1036 . 1085) (MEAS 1089 . 1327) (NUM-BETWEEN 1331 . 1440) (POINTP 1444 . 1516) (PT 1520
. 1567) (RDIST 1571 . 1778) (SLOPE 1782 . 2078) (SQ 2082 . 2158) (TRI 2162 . 2211)))))
STOP